home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue42 / system / UCAniIcon.pas < prev    next >
Pascal/Delphi Source File  |  1999-01-03  |  13KB  |  381 lines
  1. unit UCAniIcon;
  2.  
  3. interface
  4.  
  5. uses Windows, SysUtils, Consts, Classes, Graphics;
  6.  
  7. type
  8.     TAniIconHeader = record
  9.         dwSizeof: LongInt;
  10.         dwFrames: LongInt;
  11.         dwSteps: LongInt;
  12.         dwCX: LongInt;                    { use this to store icon width }
  13.         dwCY: LongInt;                    { use this to store icon height }
  14.         dwBitCount: LongInt;
  15.         dwPlanes: LongInt;
  16.         dwJIFRate: LongInt;
  17.         dwFlags: LongInt;
  18.     end;
  19.  
  20.     TAniIcon = class (TGraphic)
  21.     private
  22.         Rates: TList;                     { Optional JIFRate info for each step }
  23.         FrameOffsets: TList;              { Stream offsets into each frame }
  24.         SequenceMap: TList;               { Optional frame sequence mapping }
  25.         Image: TMemoryStream;             { Memory Image of entire .ANI file }
  26.         fAuthor: String;                  { Optional author information }
  27.         fTitle: String;                   { Optional title information }
  28.         fHeader: TAniIconHeader;          { ANI header extracted from file }
  29.         fCurrentJIFs: Integer;            { current JIF count for this step }
  30.         fCurrentStep: Integer;            { current step number }
  31.         fCurrentFrame: Integer;           { currently displaying frame number }
  32.         fCurrentIcon: hIcon;              { currently displaying icon }
  33.         fTransparent: Boolean;            { for transparent blitting }
  34.         fBackColor: TColor;               { background color when not transparent }
  35.         procedure SetFrame (Index: Integer);
  36.     public
  37.         procedure Clear;
  38.         constructor Create; override;
  39.         destructor Destroy; override;
  40.         procedure Assign (Source: TPersistent); override;
  41.         procedure LoadFromStream (Stream: TStream); override;
  42.         procedure SaveToStream (Stream: TStream); override;
  43.         procedure Animate;
  44.         procedure LoadFromClipboardFormat (AFormat: Word; AData: THandle; APalette: HPalette); override;
  45.         procedure SaveToClipboardFormat (var Format: Word; var Data: THandle; var APalette: HPalette); override;
  46.         procedure Draw (ACanvas: TCanvas; const Rect: TRect); override;
  47.         procedure SetAnimatedCursor (Index: Integer);
  48.         property Author: String read fAuthor;
  49.         property Title: String read fTitle;
  50.         property Icon: hIcon read fCurrentIcon;
  51.         property Transparent: Boolean read fTransparent write fTransparent default False;
  52.         property BackgroundColor: TColor read fBackColor write fBackColor default clBtnFace;
  53.     protected
  54.         function GetEmpty: Boolean; override;
  55.         function GetHeight: Integer; override;
  56.         function GetWidth: Integer; override;
  57.         procedure SetHeight (Value: Integer); override;
  58.         procedure SetWidth (Value: Integer); override;
  59.     end;
  60.  
  61. implementation
  62.  
  63. { TAniIcon }
  64.  
  65. uses Forms;
  66.  
  67. constructor TAniIcon.Create;
  68. begin
  69.     Inherited Create;
  70.     fTransparent := False;
  71.     fBackColor := clBtnFace;
  72.     Rates := TList.Create;
  73.     FrameOffsets := TList.Create;
  74.     SequenceMap := TList.Create;
  75.     Image := TMemoryStream.Create;
  76. end;
  77.  
  78. destructor TAniIcon.Destroy;
  79. begin
  80.     Clear;
  81.     Image.Free;
  82.     Rates.Free;
  83.     FrameOffsets.Free;
  84.     SequenceMap.Free;
  85.     Inherited Destroy;
  86. end;
  87.  
  88. procedure TAniIcon.Clear;
  89. begin
  90.     fAuthor := '--unavailable--';
  91.     fTitle := '--unavailable--';
  92.     Image.Clear;
  93.     Rates.Clear;
  94.     FrameOffsets.Clear;
  95.     SequenceMap.Clear;
  96.     if fCurrentIcon <> 0 then DestroyIcon (fCurrentIcon);
  97.     fCurrentIcon := 0;
  98.     fCurrentJIFs := 0;
  99.     fCurrentStep := 0;
  100.     fCurrentFrame := 0;
  101. end;
  102.  
  103. procedure TAniIcon.Assign (Source: TPersistent);
  104. begin
  105.     if Source = Nil then Clear
  106.     else if Source is TAniIcon then LoadFromStream (TAniIcon (Source).Image)
  107.     else Inherited Assign (Source);
  108. end;
  109.  
  110. function TAniIcon.GetEmpty: Boolean;
  111. begin
  112.     Result := FrameOffsets.Count = 0;
  113. end;
  114.  
  115. procedure TAniIcon.SetHeight (Value: Integer);
  116. begin
  117.     raise EInvalidGraphicOperation.Create (sChangeIconSize);
  118. end;
  119.  
  120. procedure TAniIcon.SetWidth (Value: Integer);
  121. begin
  122.     raise EInvalidGraphicOperation.Create (sChangeIconSize);
  123. end;
  124.  
  125. function TAniIcon.GetWidth: Integer;
  126. begin
  127.     Result := fHeader.dwCX;
  128. end;
  129.  
  130. function TAniIcon.GetHeight: Integer;
  131. begin
  132.     Result := fHeader.dwCY;
  133. end;
  134.  
  135. procedure TAniIcon.LoadFromClipboardFormat (AFormat: Word; AData: THandle; APalette: HPalette);
  136. begin
  137.     raise EInvalidGraphicOperation.Create (sIconToClipboard);
  138. end;
  139.  
  140. procedure TAniIcon.SaveToClipboardFormat (var Format: Word; var Data: THandle; var APalette: HPalette);
  141. begin
  142.     raise EInvalidGraphicOperation.Create (sIconToClipboard);
  143. end;
  144.  
  145. procedure TAniIcon.LoadFromStream (Stream: TStream);
  146. const
  147.     sig_RIFF = $46464952;         { RIFF header                         }
  148.     sig_ACON = $4E4F4341;         { ACON form type                      }
  149.     sig_LIST = $5453494C;         { LIST sub-chunk                      }
  150.     sig_INFO = $4F464E49;         { INFO sub-chunk                      }
  151.     sig_INAM = $4D414E49;         { INAM - title information            }
  152.     sig_IART = $54524149;         { IART - author information           }
  153.     sig_anih = $68696E61;         { anih - header information           }
  154.     sig_rate = $65746172;         { optional JIF rates sub-chunk        }
  155.     sig_fram = $6D617266;         { fram - list of icon frames          }
  156.     sig_icon = $6E6F6369;         { icon - start of actual frame        }
  157.     sig_seq  = $20716573;         { seq - optional sequence information }
  158.  
  159. var
  160.     ChunkLen: LongInt;
  161.     EncounteredHeader: Boolean;
  162.  
  163.     procedure InvalidFile;
  164.     begin
  165.         raise EInvalidGraphic.Create ('Animated icon image is not valid');
  166.     end;
  167.  
  168.     function ReadByte: Byte;
  169.     begin
  170.         Image.ReadBuffer (Result, sizeof (Result));
  171.     end;
  172.  
  173.     function ReadLong: LongInt;
  174.     begin
  175.         Image.ReadBuffer (Result, sizeof (Result));
  176.     end;
  177.  
  178.     function ReadString: String;
  179.     var
  180.         p: PChar;
  181.         Len: LongInt;
  182.     begin
  183.         Len := ReadLong;
  184.         if (Len and 1) <> 0 then Inc (Len);
  185.         GetMem (p, Len + 1);
  186.         p[Len] := #0;
  187.         Image.ReadBuffer (p^, Len);
  188.         Result := StrPas (p);
  189.         FreeMem (p, Len + 1);
  190.     end;
  191.  
  192.     { Process an optional info header sub-chunk. Contains Title/Author }
  193.     procedure ParseTitleAuthor;
  194.     var
  195.         ChunkEnd: LongInt;
  196.     begin
  197.         ChunkEnd := ReadLong;
  198.         Inc (ChunkEnd, Image.Position);
  199.         if ReadLong <> sig_INFO then InvalidFile;
  200.  
  201.         while Image.Position < ChunkEnd do
  202.             case ReadLong of
  203.                 sig_INAM: fTitle := ReadString;
  204.                 sig_IART: fAuthor := ReadString;
  205.             end;
  206.     end;
  207.  
  208.     { Parse ANI header information }
  209.     procedure ParseAniHeader;
  210.     begin
  211.         if ReadLong <> sizeof (fHeader) then InvalidFile;
  212.         Image.ReadBuffer (fHeader, sizeof (fHeader));
  213.         EncounteredHeader := True;
  214.     end;
  215.  
  216.     { Parse optional JIFRates chunk OR }
  217.     {       optional Sequence Map      }
  218.     procedure ParseList (List: TList);
  219.     var
  220.         Len: LongInt;
  221.     begin
  222.         Len := ReadLong div sizeof (LongInt);
  223.         if Len <> fHeader.dwSteps then InvalidFile;
  224.         while Len > 0 do begin
  225.             List.Add (Pointer (ReadLong));
  226.             Dec (Len);
  227.         end;
  228.     end;
  229.  
  230.     { Parse the actual icon data itself }
  231.     procedure ParseIconList;
  232.     var
  233.         Idx: Integer;
  234.         Len, Next: LongInt;
  235.     begin
  236.         ReadLong; { Discard chunk length }
  237.         if ReadLong <> sig_fram then InvalidFile;
  238.         { Store frame offsets for later consumption }
  239.         for Idx := 0 to fHeader.dwFrames - 1 do begin
  240.             if ReadLong <> sig_icon then InvalidFile;
  241.             { Save position from beginning of length dword }
  242.             FrameOffsets.Add (Pointer (Image.Position));
  243.             { Read Length of this frame }
  244.             Len := ReadLong;
  245.             Next := Len + Image.Position;
  246.             { Dig a little deeper to get the icon size info }
  247.             if Idx = 0 then begin
  248.                 Image.Position := Image.Position + 6;
  249.                 fHeader.dwCX := ReadByte;
  250.                 fHeader.dwCY := ReadByte;
  251.             end;
  252.  
  253.             Image.Position := Next;
  254.         end;
  255.     end;
  256.  
  257. begin { LoadFromStream }
  258.     Clear;
  259.     { If stream size is 0, we're done }
  260.     if Stream.Size = 0 then Exit;
  261.     Image.LoadFromStream (Stream);
  262.     EncounteredHeader := False;
  263.     { Validate initial eight-byte header }
  264.     { Note: Some .ANI files have filesize > header (e.g. appstart.ani) }
  265.     if (ReadLong <> sig_RIFF) or (ReadLong > Image.Size) then InvalidFile;
  266.     { Next item must be an ACON chunk }
  267.     if ReadLong <> sig_ACON then InvalidFile;
  268.  
  269.     while Image.Position < Image.Size do
  270.         { Case out on the sub-chunk we find }
  271.         case ReadLong of
  272.             sig_LIST: if not EncounteredHeader then ParseTitleAuthor else ParseIconList;
  273.             sig_anih: ParseAniHeader;
  274.             sig_rate: ParseList (Rates);
  275.             sig_seq:  ParseList (SequenceMap);
  276.  
  277.             else      begin { Unknown chunk - just skip it }
  278.                           ChunkLen := ReadLong;
  279.                           Image.Position := Image.Position + ChunkLen;
  280.                       end;
  281.         end;
  282.  
  283.     SetFrame (0);
  284. end;
  285.  
  286. procedure TAniIcon.SaveToStream (Stream: TStream);
  287. begin
  288.     if GetEmpty then raise EInvalidGraphicOperation.Create (sInvalidImage);
  289.     with Image do Stream.WriteBuffer (Memory^, Size);
  290. end;
  291.  
  292. procedure TAniIcon.Draw (ACanvas: TCanvas; const Rect: TRect);
  293. var
  294.     bm: TBitmap;
  295. begin
  296.     if fCurrentIcon <> 0 then begin
  297.         if not fTransparent then begin
  298.             bm := TBitmap.Create;
  299.             bm.Width := fHeader.dwCX;
  300.             bm.Height := fHeader.dwCY;
  301.             bm.Canvas.Brush.Color := fBackColor;
  302.             bm.Canvas.FillRect (Classes.Rect (0, 0, bm.Width, bm.Height));
  303.             DrawIcon (bm.Canvas.Handle, 0, 0, fCurrentIcon);
  304.             ACanvas.Draw (Rect.Left, Rect.Top, bm);
  305.             bm.Free;
  306.         end else DrawIcon (ACanvas.Handle, Rect.Left, Rect.Top, fCurrentIcon);
  307.     end;
  308. end;
  309.  
  310. procedure TAniIcon.SetFrame (Index: Integer);
  311. type
  312.     TIconHeader = packed record
  313.         AlwaysZero: Word;
  314.         CursorType: Word;
  315.         NumIcons: Word;
  316.     end;
  317.  
  318.     TIconDirEntry = packed record
  319.         Width, Height, Colors: Byte;
  320.         Reserved: Byte;
  321.         dwReserved: LongInt;
  322.         dwBytesInRes: LongInt;
  323.         dwImageOffset: LongInt;
  324.     end;
  325.  
  326. var
  327.     p: PByte;
  328.     ChunkLen: LongInt;
  329.     IconHeader: TIconHeader;
  330. begin
  331.     if (FrameOffsets.Count <> 0) and (Index < fHeader.dwFrames) then begin
  332.        fCurrentFrame := Index;
  333.        // Delete any existing icon
  334.        if fCurrentIcon <> 0 then DestroyIcon (fCurrentIcon);
  335.        // Seek to wanted position in stream data
  336.        Image.Position := Integer (FrameOffsets [Index]);
  337.        Image.ReadBuffer (ChunkLen, sizeof (ChunkLen));
  338.        Image.ReadBuffer (IconHeader, sizeof (IconHeader));
  339.        Image.Position := Image.Position + (sizeof (TIconDirEntry) * IconHeader.NumIcons);
  340.        Dec (ChunkLen, sizeof (IconHeader) + (sizeof (TIconDirEntry) * IconHeader.NumIcons));
  341.  
  342.        p := Image.Memory; Inc (p, Image.Position);
  343.        fCurrentIcon := CreateIconFromResource (p, ChunkLen, True, $30000);
  344.        Changed (Self);
  345.     end;
  346. end;
  347.  
  348. procedure TAniIcon.Animate;
  349. var
  350.     JifRate, NextFrame: Integer;
  351. begin
  352.     if Rates.Count = 0 then JifRate := fHeader.dwJIFRate else JifRate := Integer (Rates [fCurrentStep]);
  353.     Inc (fCurrentJIFs, 4);
  354.     if fCurrentJIFs >= JifRate then begin
  355.         { Time to move on to next step }
  356.         fCurrentJIFs := 0;
  357.         Inc (fCurrentStep);
  358.         if fCurrentStep >= fHeader.dwSteps then fCurrentStep := 0;
  359.         if SequenceMap.Count = 0 then NextFrame := fCurrentFrame + 1 else NextFrame := Integer (SequenceMap [fCurrentStep]);
  360.         if NextFrame >= fHeader.dwFrames then NextFrame := 0;
  361.         if NextFrame <> fCurrentFrame then SetFrame (NextFrame);
  362.     end;
  363. end;
  364.  
  365. procedure TAniIcon.SetAnimatedCursor (Index: Integer);
  366. var
  367.     TempFileName: String;
  368. begin
  369.     if not Empty then begin
  370.         TempFileName := FormatDateTime ('__$$hhnnss$$__', Now);
  371.         SaveToFile (TempFileName);
  372.         try
  373.             Screen.Cursors [Index] := LoadImage (0, PChar (TempFileName), Image_Cursor, 0, 0, lr_LoadFromFile);
  374.         finally
  375.         DeleteFile (TempFileName);
  376.         end;
  377.     end;
  378. end;
  379.  
  380. end.
  381.